home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGASIC / BASFILES.LZH / QBTXKILL.BAS < prev    next >
BASIC Source File  |  1988-09-10  |  13KB  |  237 lines
  1. '$INCLUDE:'QBTOOLS.INC'
  2. '' '$INCLUDE: 'qbtools2.inc'
  3. '' '$INCLUDE: 'qbt2indx.inc'
  4. '' '-------------------------Standard Include Merge Section-------------------
  5.  
  6. DEFSNG A-Z
  7.     SUB IndexKill (IxNum%, Ky$, Mrec%, Xnm$(), Xk$(), Xh%(), sc%) STATIC
  8.  
  9.         IF Mrec% < 1 THEN
  10.             GOTO badkey
  11.         END IF
  12.  
  13.         IF sc% < 1 THEN
  14.             GOTO badkey
  15.         END IF
  16.  
  17.         GET #IxNum%, sc%                                           ' key to delete
  18.  
  19.         dk$ = Xk$(IxNum%, 1)                                       ' key
  20.         ds% = sc%                                                  ' position in file
  21.         dl% = CVI(Xk$(IxNum%, 2))                                  ' left pointer
  22.         dr% = CVI(Xk$(IxNum%, 3))                                  ' right pointer
  23.         dp% = CVI(Xk$(IxNum%, 4))                                  ' parent pointer
  24.         dm% = CVI(Xk$(IxNum%, 5))                                  ' pointer to ACTUAL record
  25.         dd% = CVI(Xk$(IxNum%, 6))                                  ' pointer to next deleted
  26.  
  27.         IF (dp% <> 0) THEN                                         ' there IS a parent
  28.  
  29.             REM $subtitle:'There is a parent and a left child'
  30.             REM $page
  31.             IF (dl% <> 0) AND (dr% = 0) THEN                        ' left ONLY
  32.                 GET #IxNum%, dp%                                     ' get the parent
  33.                 IF CVI(Xk$(IxNum%, 2)) = ds% THEN                    ' yes, link to the left
  34.                     side% = 2
  35.                 ELSE
  36.                     side% = 3                                         ' otherwise, right
  37.                 END IF
  38.                 LSET Xk$(IxNum%, side%) = MKI$(dl%)                  ' change the link
  39.                 PUT #IxNum%, dp%                                     ' write it back
  40.                 GET #IxNum%, dl%                                     ' get the kid
  41.                 LSET Xk$(IxNum%, 4) = MKI$(dp%)                      ' relink the child
  42.                 PUT #IxNum%, dl%                                     ' write it back
  43.                 GOSUB initkeyrec                                     ' init the record
  44.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  45.                 PUT #IxNum%, ds%                                     ' write it away
  46.                 Xh%(IxNum%, 4) = ds%                                 ' new deleted lifo rec
  47.             END IF
  48.             REM $subtitle:'There is a parent and a right child'
  49.             REM $page
  50.             IF (dr% <> 0) AND (dl% = 0) THEN                        ' right ONLY
  51.                 GET #IxNum%, dp%                                     ' get the parent
  52.                 IF CVI(Xk$(IxNum%, 2)) = ds% THEN                    ' yes, link to the left
  53.                     side% = 2
  54.                 ELSE
  55.                     side% = 3                                         ' otherwise, right
  56.                 END IF
  57.                 LSET Xk$(IxNum%, side%) = MKI$(dr%)                  ' change the link
  58.                 PUT #IxNum%, dp%                                     ' write it back
  59.                 GET #IxNum%, dr%                                     ' get the kid
  60.                 LSET Xk$(IxNum%, 4) = MKI$(dp%)                      ' relink the child
  61.                 PUT #IxNum%, dr%                                     ' write it back
  62.                 GOSUB initkeyrec                                     ' init the record
  63.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  64.                 PUT #IxNum%, ds%                                     ' write it away
  65.                 Xh%(IxNum%, 4) = ds%                                 ' new deleted lifo rec
  66.             END IF
  67.             REM $subtitle:'There is a parent , but no children'
  68.             REM $page
  69.             IF ((dl% = 0) AND (dr% = 0)) THEN                       ' NO children
  70.                 GET #IxNum%, dp%                                     ' get the parent
  71.                 IF CVI(Xk$(IxNum%, 2)) = ds% THEN                    ' yes, link to the left
  72.                     side% = 2
  73.                 ELSE
  74.                     side% = 3                                         ' otherwise, right
  75.                 END IF
  76.                 LSET Xk$(IxNum%, side%) = MKI$(0)                    ' change the link
  77.                 PUT #IxNum%, dp%                                     ' write it back
  78.                 GOSUB initkeyrec                                     ' init the record
  79.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  80.                 PUT #IxNum%, ds%                                     ' write it away
  81.                 Xh%(IxNum%, 4) = ds%                                 ' new deleted lifo rec
  82.             END IF
  83.             REM $subtitle:'There is a parent and both left & right children'
  84.             REM $page
  85.             IF (dl% <> 0) AND (dr% <> 0) THEN                       ' Yup, two kids
  86.                 GET #IxNum%, dl%                                     ' get the left
  87.                 LSET Xk$(IxNum%, 4) = MKI$(dp%)                      ' give a new parent
  88.                 PUT #IxNum%, dl%                                     ' write it back
  89.                 pnh% = dl%                                           ' last key so far
  90.                 nh% = CVI(Xk$(IxNum%, 3))                            ' right key
  91.                 WHILE nh% <> 0                                       ' keep getting
  92.                     GET #IxNum%, nh%                                  ' get right
  93.                     pnh% = nh%                                        ' last key so far
  94.                     nh% = CVI(Xk$(IxNum%, 3))                         ' right key
  95.                 WEND
  96.                 LSET Xk$(IxNum%, 3) = MKI$(dr%)                      ' link deleted's right to this
  97.                 PUT #IxNum%, pnh%                                    ' write this one back
  98.                 GET #IxNum%, dr%                                     ' get the right one
  99.                 LSET Xk$(IxNum%, 4) = MKI$(pnh%)                     ' set the new parent
  100.                 PUT #IxNum%, dr%                                     ' write it back
  101.                 GET #IxNum%, dp%                                     ' fetch the parent
  102.                 IF CVI(Xk$(IxNum%, 2)) = ds% THEN                    ' yes, link to the left
  103.                     side% = 2
  104.                 ELSE
  105.                     side% = 3                                         ' otherwise, right
  106.                 END IF
  107.                 LSET Xk$(IxNum%, side%) = MKI$(dl%)                  ' change the link
  108.                 PUT #IxNum%, dp%                                     ' write it back
  109.                 GOSUB initkeyrec                                     ' init the record
  110.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  111.                 PUT #IxNum%, ds%                                     ' write it away
  112.                 Xh%(IxNum%, 4) = ds%                                 ' new deleted lifo rec
  113.             END IF
  114.  
  115.         ELSEIF (ds% = 1) THEN                                      ' NO PARENT
  116.             REM $subtitle:'No parent, and there is a left child'
  117.             REM $page
  118.             IF (dl% <> 0) AND (dr% = 0) THEN                        ' left ONLY
  119.                 GET #IxNum%, dl%                                     ' get left
  120.                 lrec% = CVI(Xk$(IxNum%, 2))                          ' the left grandchild
  121.                 rrec% = CVI(Xk$(IxNum%, 3))                          ' the right grandchild
  122.                 LSET Xk$(IxNum%, 4) = MKI$(0)                        ' no parent for this
  123.                 PUT #IxNum%, 1                                       ' write to 1
  124.                 IF (lrec% <> 0) THEN                                 ' yes, theres a left gc
  125.                     GET #IxNum%, lrec%                                ' get the left grandchild
  126.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  127.                     PUT #IxNum%, lrec%                                ' put this record away
  128.                 END IF
  129.                 IF (rrec% <> 0) THEN                                 ' yes, theres a right gc
  130.                     GET #IxNum%, rrec%                                ' get the right grandchild
  131.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  132.                     PUT #IxNum%, rrec%                                ' put this record away
  133.                 END IF
  134.                 GOSUB initkeyrec                                     ' init the record
  135.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  136.                 PUT #IxNum%, dl%                                     ' write it away
  137.                 Xh%(IxNum%, 4) = dl%                                 ' new deleted lifo rec
  138.             END IF
  139.             REM $subtitle:'No parent, and there is a right child'
  140.             REM $page
  141.             IF (dr% <> 0) AND (dl% = 0) THEN                        ' right ONLY
  142.                 GET #IxNum%, dr%                                     ' get right
  143.                 lrec% = CVI(Xk$(IxNum%, 2))                          ' the left grandchild
  144.                 rrec% = CVI(Xk$(IxNum%, 3))                          ' the right grandchild
  145.                 LSET Xk$(IxNum%, 4) = MKI$(0)                        ' no parent for this
  146.                 PUT #IxNum%, 1                                       ' write to 1
  147.                 IF (lrec% <> 0) THEN                                 ' yes, theres a left gc
  148.                     GET #IxNum%, lrec%                                ' get the left grandchild
  149.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  150.                     PUT #IxNum%, lrec%                                ' put this record away
  151.                 END IF
  152.                 IF (rrec% <> 0) THEN                                 ' yes, theres a right gc
  153.                     GET #IxNum%, rrec%                                ' get the right grandchild
  154.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  155.                     PUT #IxNum%, rrec%                                ' put this record away
  156.                 END IF
  157.  
  158.                 GOSUB initkeyrec                                     ' init the record
  159.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  160.                 PUT #IxNum%, dr%                                     ' write it away
  161.                 Xh%(IxNum%, 4) = dr%                                 ' new deleted lifo rec
  162.             END IF
  163.             REM $subtitle:'No parent and no children'
  164.             REM $page
  165.             IF ((dl% = 0) AND (dr% = 0)) THEN                       ' NO children, NO parents, lonely!
  166.                                 ' Just in case index is large ...
  167.                 CLOSE #IxNum%                                        ' close the index
  168.                 hn$ = Xnm$(IxNum%)                                   ' Name of the index
  169.                 kl% = Xh%(IxNum%, 1)                                 ' Key Length
  170.  
  171.                 CALL IndexCreate(IxNum%, hn$, kl%)                   ' Re-create the file
  172.                 IF aesbfatal% THEN                                   ' Fatal error opening index
  173.                     CALL IndexError("BITKIL/BITCRE(RE)")
  174.                 END IF
  175.                 CALL IndexOpen(IxNum%, hn$, Xnm$(), Xk$(), Xh%())    ' Ya got it, just create it again
  176.             END IF
  177.             REM $subtitle:'No parent, but both left and right children'
  178.             REM $page
  179.             IF (dl% <> 0) AND (dr% <> 0) THEN                       ' Yup, two kids
  180.                 GET #IxNum%, dl%                                     ' get the left
  181.                 lrec% = CVI(Xk$(IxNum%, 2))                          ' the left grandchild
  182.                 rrec% = CVI(Xk$(IxNum%, 3))                          ' the right grandchild
  183.                 LSET Xk$(IxNum%, 4) = MKI$(0)                        ' no parent for this
  184.                 PUT #IxNum%, 1                                       ' write to 1
  185.                 IF (lrec% <> 0) THEN                                 ' yes, theres a left gc
  186.                     GET #IxNum%, lrec%                                ' get the left grandchild
  187.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  188.                     PUT #IxNum%, lrec%                                ' put this record away
  189.                 END IF
  190.                 IF (rrec% <> 0) THEN                                 ' yes, theres a right gc
  191.                     GET #IxNum%, rrec%                                ' get the right grandchild
  192.                     LSET Xk$(IxNum%, 4) = MKI$(1)                     ' new parent
  193.                     PUT #IxNum%, rrec%                                ' put this record away
  194.                 END IF
  195.                 GET #IxNum%, 1                                       ' get left again
  196.                                 ' thats where the new record is now
  197.                 pnh% = 1                                             ' last key so far
  198.                 nh% = CVI(Xk$(IxNum%, 3))                            ' right key
  199.                 WHILE nh% <> 0                                       ' keep getting
  200.                     GET #IxNum%, nh%                                  ' get right
  201.                     pnh% = nh%                                        ' last key so far
  202.                     nh% = CVI(Xk$(IxNum%, 3))                         ' right key
  203.                 WEND
  204.                 LSET Xk$(IxNum%, 3) = MKI$(dr%)                      ' link deleted's right to this
  205.                 PUT #IxNum%, pnh%                                    ' write this one back
  206.                 GET #IxNum%, dr%                                     ' get the right one
  207.                 LSET Xk$(IxNum%, 4) = MKI$(pnh%)                     ' set the new parent
  208.                 PUT #IxNum%, dr%                                     ' write it back
  209.                 GOSUB initkeyrec                                     ' init the record
  210.                 LSET Xk$(IxNum%, 6) = MKI$(Xh%(IxNum%, 4))           ' allocate on stack
  211.                 PUT #IxNum%, dl%                                     ' write it away
  212.                 Xh%(IxNum%, 4) = dl%                                 ' new deleted lifo rec
  213.             END IF
  214.  
  215.         END IF
  216.  
  217.         GOTO goodkey
  218.         REM $subtitle:'Initialize a key to blanks'
  219.         REM $page
  220. initkeyrec: ' Initialize the key
  221.         FOR j% = 2 TO 6
  222.             LSET Xk$(IxNum%, j%) = MKI$(0)
  223.         NEXT j%
  224.         LSET Xk$(IxNum%, 1) = STRING$(Xh%(IxNum%, 1) + 10, 0)
  225.         Xh%(IxNum%, 2) = Xh%(IxNum%, 2) - 1
  226.         RETURN
  227.  
  228. goodkey:
  229.         sc% = 1
  230.         GOTO deleted
  231. badkey:
  232.         Mrec% = 0
  233.         sc% = 0
  234. deleted:
  235.     END SUB
  236.  
  237.